home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / dev / gg / ncurses-5.3.lha / ncurses-5.3 / Ada95 / samples / ncurses2-m.adb < prev    next >
Text File  |  2002-10-24  |  16KB  |  461 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                       GNAT ncurses Binding Samples                       --
  4. --                                                                          --
  5. --                                 ncurses                                  --
  6. --                                                                          --
  7. --                                 B O D Y                                  --
  8. --                                                                          --
  9. ------------------------------------------------------------------------------
  10. -- Copyright (c) 2000 Free Software Foundation, Inc.                        --
  11. --                                                                          --
  12. -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13. -- copy of this software and associated documentation files (the            --
  14. -- "Software"), to deal in the Software without restriction, including      --
  15. -- without limitation the rights to use, copy, modify, merge, publish,      --
  16. -- distribute, distribute with modifications, sublicense, and/or sell       --
  17. -- copies of the Software, and to permit persons to whom the Software is    --
  18. -- furnished to do so, subject to the following conditions:                 --
  19. --                                                                          --
  20. -- The above copyright notice and this permission notice shall be included  --
  21. -- in all copies or substantial portions of the Software.                   --
  22. --                                                                          --
  23. -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24. -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25. -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26. -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27. -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28. -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29. -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30. --                                                                          --
  31. -- Except as contained in this notice, the name(s) of the above copyright   --
  32. -- holders shall not be used in advertising or otherwise to promote the     --
  33. -- sale, use or other dealings in this Software without prior written       --
  34. -- authorization.                                                           --
  35. ------------------------------------------------------------------------------
  36. --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37. --  Version Control
  38. --  $Revision: 1.1 $
  39. --  Binding Version 01.00
  40. ------------------------------------------------------------------------------
  41. --  TODO use Default_Character where appropriate
  42.  
  43. --  This is an Ada version of ncurses
  44. --  I translated this because it tests the most features.
  45.  
  46. with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  47. with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
  48.  
  49. with Ada.Text_IO; use Ada.Text_IO;
  50.  
  51. with Ada.Characters.Latin_1;
  52. --  with Ada.Characters.Handling;
  53.  
  54. with Ada.Command_Line; use Ada.Command_Line;
  55.  
  56. with Ada.Strings.Unbounded;
  57.  
  58.  
  59. with ncurses2.util; use ncurses2.util;
  60. with ncurses2.getch_test;
  61. with ncurses2.attr_test;
  62. with ncurses2.color_test;
  63. with ncurses2.demo_panels;
  64. with ncurses2.color_edit;
  65. with ncurses2.slk_test;
  66. with ncurses2.acs_display;
  67. with ncurses2.color_edit;
  68. with ncurses2.acs_and_scroll;
  69. with ncurses2.flushinp_test;
  70. with ncurses2.test_sgr_attributes;
  71. with ncurses2.menu_test;
  72. with ncurses2.demo_pad;
  73. with ncurses2.demo_forms;
  74. with ncurses2.overlap_test;
  75. with ncurses2.trace_set;
  76.  
  77. with ncurses2.getopt; use ncurses2.getopt;
  78.  
  79. package body ncurses2.m is
  80.    use Int_IO;
  81.  
  82.    function To_trace (n : Integer) return Trace_Attribute_Set;
  83.    procedure usage;
  84.    procedure Set_Terminal_Modes;
  85.    function Do_Single_Test (c : Character) return Boolean;
  86.  
  87.    function To_trace (n : Integer) return Trace_Attribute_Set is
  88.       a : Trace_Attribute_Set := (others => False);
  89.       m : Integer;
  90.       rest : Integer;
  91.    begin
  92.       m := n  mod 2;
  93.       if 1 = m then
  94.          a.Times := True;
  95.       end if;
  96.       rest := n / 2;
  97.  
  98.       m := rest mod 2;
  99.       if 1 = m then
  100.          a.Tputs := True;
  101.       end if;
  102.       rest := rest / 2;
  103.       m := rest mod 2;
  104.       if 1 = m then
  105.          a.Update := True;
  106.       end if;
  107.       rest := rest / 2;
  108.       m := rest mod 2;
  109.       if 1 = m then
  110.          a.Cursor_Move := True;
  111.       end if;
  112.       rest := rest / 2;
  113.       m := rest mod 2;
  114.       if 1 = m then
  115.          a.Character_Output := True;
  116.       end if;
  117.       rest := rest / 2;
  118.       m := rest mod 2;
  119.       if 1 = m then
  120.          a.Calls := True;
  121.       end if;
  122.       rest := rest / 2;
  123.       m := rest mod 2;
  124.       if 1 = m then
  125.          a.Virtual_Puts := True;
  126.       end if;
  127.       rest := rest / 2;
  128.       m := rest mod 2;
  129.       if 1 = m then
  130.          a.Input_Events := True;
  131.       end if;
  132.       rest := rest / 2;
  133.       m := rest mod 2;
  134.       if 1 = m then
  135.          a.TTY_State := True;
  136.       end if;
  137.       rest := rest / 2;
  138.       m := rest mod 2;
  139.       if 1 = m then
  140.          a.Internal_Calls := True;
  141.       end if;
  142.       rest := rest / 2;
  143.       m := rest mod 2;
  144.       if 1 = m then
  145.          a.Character_Calls := True;
  146.       end if;
  147.       rest := rest / 2;
  148.       m := rest mod 2;
  149.       if 1 = m then
  150.          a.Termcap_TermInfo := True;
  151.       end if;
  152.  
  153.       return a;
  154.    end To_trace;
  155.  
  156.    --   these are type Stdscr_Init_Proc;
  157.  
  158.    function rip_footer (
  159.                         Win : Window;
  160.                         Columns : Column_Count) return Integer;
  161.    pragma Convention (C, rip_footer);
  162.  
  163.    function rip_footer (
  164.                         Win : Window;
  165.                         Columns : Column_Count) return Integer is
  166.    begin
  167.       Set_Background (Win, (Ch => ' ',
  168.                             Attr => (Reverse_Video => True, others => False),
  169.                             Color => 0));
  170.       Erase (Win);
  171.       Move_Cursor (Win, 0, 0);
  172.       Add (Win, "footer:"  & Columns'Img & " columns");
  173.       Refresh_Without_Update (Win);
  174.       return 0; -- Curses_OK;
  175.    end rip_footer;
  176.  
  177.  
  178.    function rip_header (
  179.                         Win : Window;
  180.                         Columns : Column_Count) return Integer;
  181.    pragma Convention (C, rip_header);
  182.  
  183.    function rip_header (
  184.                         Win : Window;
  185.                         Columns : Column_Count) return Integer is
  186.    begin
  187.       Set_Background (Win, (Ch => ' ',
  188.                             Attr => (Reverse_Video => True, others => False),
  189.                             Color => 0));
  190.       Erase (Win);
  191.       Move_Cursor (Win, 0, 0);
  192.       Add (Win, "header:"  & Columns'Img & " columns");
  193.       --  'Img is a GNAT extention
  194.       Refresh_Without_Update (Win);
  195.       return 0; -- Curses_OK;
  196.    end rip_header;
  197.  
  198.    procedure usage is
  199.       --  type Stringa is access String;
  200.       use Ada.Strings.Unbounded;
  201.       --  tbl : constant array (Positive range <>) of Stringa := (
  202.       tbl : constant array (Positive range <>) of Unbounded_String
  203.         := (
  204.             To_Unbounded_String ("Usage: ncurses [options]"),
  205.             To_Unbounded_String (""),
  206.             To_Unbounded_String ("Options:"),
  207.             To_Unbounded_String ("  -a f,b   set default-colors " &
  208.                                  "(assumed white-on-black)"),
  209.             To_Unbounded_String ("  -d       use default-colors if terminal " &
  210.                                  "supports them"),
  211.             To_Unbounded_String ("  -e fmt   specify format for soft-keys " &
  212.                                  "test (e)"),
  213.             To_Unbounded_String ("  -f       rip-off footer line " &
  214.                                  "(can repeat)"),
  215.             To_Unbounded_String ("  -h       rip-off header line " &
  216.                                  "(can repeat)"),
  217.             To_Unbounded_String ("  -s msec  specify nominal time for " &
  218.                                  "panel-demo (default: 1, to hold)"),
  219.             To_Unbounded_String ("  -t mask  specify default trace-level " &
  220.                                  "(may toggle with ^T)")
  221.             );
  222.    begin
  223.       for n in tbl'Range loop
  224.          Put_Line (Standard_Error, To_String (tbl (n)));
  225.       end loop;
  226.       --     exit(EXIT_FAILURE);
  227.       --  TODO should we use Set_Exit_Status and throw and exception?
  228.    end usage;
  229.  
  230.    procedure Set_Terminal_Modes is begin
  231.       Set_Raw_Mode (SwitchOn => False);
  232.       Set_Cbreak_Mode (SwitchOn => True);
  233.       Set_Echo_Mode (SwitchOn => False);
  234.       Allow_Scrolling (Mode => True);
  235.       Use_Insert_Delete_Line (Do_Idl => True);
  236.       Set_KeyPad_Mode (SwitchOn => True);
  237.    end Set_Terminal_Modes;
  238.  
  239.  
  240.    nap_msec : Integer := 1;
  241.  
  242.    function Do_Single_Test (c : Character) return Boolean is
  243.    begin
  244.       case c is
  245.          when 'a' =>
  246.             getch_test;
  247.          when 'b' =>
  248.             attr_test;
  249.          when 'c' =>
  250.             if not Has_Colors then
  251.                Cannot ("does not support color.");
  252.             else
  253.                color_test;
  254.             end if;
  255.          when 'd' =>
  256.             if not Has_Colors then
  257.                Cannot ("does not support color.");
  258.             elsif not Can_Change_Color then
  259.                Cannot ("has hardwired color values.");
  260.             else
  261.                color_edit;
  262.             end if;
  263.          when 'e' =>
  264.             slk_test;
  265.          when 'f' =>
  266.             acs_display;
  267.          when 'o' =>
  268.             demo_panels (nap_msec);
  269.          when 'g' =>
  270.             acs_and_scroll;
  271.          when 'i' =>
  272.             flushinp_test (Standard_Window);
  273.          when 'k' =>
  274.             test_sgr_attributes;
  275.          when 'm' =>
  276.             menu_test;
  277.          when 'p' =>
  278.             demo_pad;
  279.          when 'r' =>
  280.             demo_forms;
  281.          when 's' =>
  282.             overlap_test;
  283.          when 't' =>
  284.             trace_set;
  285.          when '?' =>
  286.             null;
  287.          when others => return False;
  288.       end case;
  289.       return True;
  290.    end Do_Single_Test;
  291.  
  292.  
  293.    command : Character;
  294.    my_e_param : Soft_Label_Key_Format := Four_Four;
  295.    assumed_colors : Boolean := False;
  296.    default_colors : Boolean := False;
  297.    default_fg : Color_Number := White;
  298.    default_bg : Color_Number := Black;
  299.    --  nap_msec was an unsigned long integer in the C version,
  300.    --  yet napms only takes an int!
  301.  
  302.    c : Integer;
  303.    c2 : Character;
  304.    optind : Integer := 1; -- must be initialized to one.
  305.    type stringa is access String;
  306.    optarg : getopt.stringa;
  307.  
  308.    length : Integer;
  309.    tmpi : Integer;
  310.  
  311.    package myio is new Ada.Text_IO.Integer_IO (Integer);
  312.    use myio;
  313.  
  314.    save_trace : Integer := 0;
  315.    save_trace_set : Trace_Attribute_Set;
  316.  
  317.    function main return Integer is
  318.    begin
  319.       loop
  320.          Qgetopt (c, Argument_Count, Argument'Access,
  321.                   "a:de:fhs:t:", optind, optarg);
  322.          exit when c = -1;
  323.          c2 := Character'Val (c);
  324.          case c2 is
  325.             when 'a' =>
  326.                --  Ada doesn't have scanf, it doesn't even have a
  327.                --  regular expression library.
  328.                assumed_colors := True;
  329.                myio.Get (optarg.all, Integer (default_fg), length);
  330.                myio.Get (optarg.all (length + 2 .. optarg.all'Length),
  331.                          Integer (default_bg), length);
  332.             when 'd' =>
  333.                default_colors := True;
  334.             when 'e' =>
  335.                myio.Get (optarg.all, tmpi, length);
  336.                if Integer (tmpi) > 3 then
  337.                   usage;
  338.                   return 1;
  339.                end if;
  340.                my_e_param := Soft_Label_Key_Format'Val (tmpi);
  341.             when 'f' =>
  342.                Rip_Off_Lines (-1, rip_footer'Access);
  343.             when 'h' =>
  344.                Rip_Off_Lines (1, rip_header'Access);
  345.             when 's' =>
  346.                myio.Get (optarg.all, nap_msec, length);
  347.             when 't' =>
  348.                myio.Get (optarg.all, save_trace, length);
  349.             when others =>
  350.                usage;
  351.                return 1;
  352.          end case;
  353.       end loop;
  354.  
  355.       --  the C version had a bunch of macros here.
  356.  
  357.       --   if (!isatty(fileno(stdin)))
  358.       --   isatty is not available in the standard Ada so skip it.
  359.       save_trace_set := To_trace (save_trace);
  360.       Trace_On (save_trace_set);
  361.  
  362.  
  363.       Init_Soft_Label_Keys (my_e_param);
  364.  
  365.       Init_Screen;
  366.       Set_Background (Ch => (Ch    => Blank,
  367.                              Attr  => Normal_Video,
  368.                              Color => Color_Pair'First));
  369.  
  370.       if Has_Colors then
  371.          Start_Color;
  372.          if default_colors then
  373.             Use_Default_Colors;
  374.          elsif assumed_colors then
  375.             Assume_Default_Colors (default_fg, default_bg);
  376.          end if;
  377.       end if;
  378.  
  379.       Set_Terminal_Modes;
  380.       Save_Curses_Mode (Curses);
  381.  
  382.       End_Windows;
  383.  
  384.       --  TODO add macro #if blocks.
  385.       Put_Line ("Welcome to " & Curses_Version & ".  Press ? for help.");
  386.  
  387.       loop
  388.          Put_Line ("This is the ncurses main menu");
  389.          Put_Line ("a = keyboard and mouse input test");
  390.          Put_Line ("b = character attribute test");
  391.          Put_Line ("c = color test pattern");
  392.          Put_Line ("d = edit RGB color values");
  393.          Put_Line ("e = exercise soft keys");
  394.          Put_Line ("f = display ACS characters");
  395.          Put_Line ("g = display windows and scrolling");
  396.          Put_Line ("i = test of flushinp()");
  397.          Put_Line ("k = display character attributes");
  398.          Put_Line ("m = menu code test");
  399.          Put_Line ("o = exercise panels library");
  400.          Put_Line ("p = exercise pad features");
  401.          Put_Line ("q = quit");
  402.          Put_Line ("r = exercise forms code");
  403.          Put_Line ("s = overlapping-refresh test");
  404.          Put_Line ("t = set trace level");
  405.          Put_Line ("? = repeat this command summary");
  406.  
  407.          Put ("> ");
  408.          Flush;
  409.  
  410.          command := Ada.Characters.Latin_1.NUL;
  411.          --              get_input:
  412.          --              loop
  413.          declare
  414.             Ch : Character;
  415.          begin
  416.             Get (Ch);
  417.             --  TODO if read(ch) <= 0
  418.             --  TODO ada doesn't have an Is_Space function
  419.             command := Ch;
  420.             --  TODO if ch = '\n' or '\r' are these in Ada?
  421.          end;
  422.          --              end loop get_input;
  423.  
  424.          declare
  425.          begin
  426.             if Do_Single_Test (command) then
  427.                Flush_Input;
  428.                Set_Terminal_Modes;
  429.                Reset_Curses_Mode (Curses);
  430.                Clear;
  431.                Refresh;
  432.                End_Windows;
  433.                if command = '?' then
  434.                   Put_Line ("This is the ncurses capability tester.");
  435.                   Put_Line ("You may select a test from the main menu by " &
  436.                             "typing the");
  437.                   Put_Line ("key letter of the choice (the letter to left " &
  438.                             "of the =)");
  439.                   Put_Line ("at the > prompt.  The commands `x' or `q' will " &
  440.                             "exit.");
  441.                end if;
  442.                --  continue; --why continue in the C version?
  443.             end if;
  444.          exception
  445.             when Curses_Exception => End_Windows;
  446.          end;
  447.  
  448.          exit when command = 'q';
  449.       end loop;
  450.       return 0; -- TODO ExitProgram(EXIT_SUCCESS);
  451.    end main;
  452.  
  453. end ncurses2.m;
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.